home *** CD-ROM | disk | FTP | other *** search
/ Apple II Magazines (PO) / Nibble Volume 11, No. 08 (1990-08)(MindCraft Publishing)(Side A).zip / Nibble Volume 11, No. 08 (1990-08)(MindCraft Publishing)(Side A).po / VIRT.MEM.S < prev   
Text File  |  1996-12-24  |  24KB  |  923 lines
  1. ********************************
  2. * VIRT.MEM.OBJ SOURCE CODE     *
  3. * BY JOHN R. VOKEY             *
  4. * COPYRIGHT (C) 1990           *
  5. * MINDCRAFT PUBL. CORP.        *
  6. * CONCORD, MA  01742           *
  7. ********************************
  8.  
  9. *   (Merlin 8/16 assembler)
  10.  
  11. *===============================
  12. *            Equates
  13. *===============================
  14.  
  15. *--------Applesoft BASIC--------
  16.  
  17. TXTPTR    equ $B8
  18. INDEX     equ $5E
  19. CHKSTR    equ $DD6C
  20. FRETMP    equ $E604
  21. MEMERR    equ $D410
  22. ERROR     equ MEMERR+2
  23. NOTFOUND  equ $E1B8
  24. ARYFOUND  equ $E19E
  25. CHKCOM    equ $DEBE
  26. CHRGOT    equ $B7
  27. DIMFLG    equ $10
  28. VARNAM    equ $81
  29. ISLETC    equ $E07D
  30. SYNERR    equ $DEC9
  31. VALTYP    equ $11
  32. INTFLG    equ $12
  33. CHRGET    equ $B1
  34. MAKINT    equ $E102
  35. FAC       equ $9D
  36. GETARY    equ $E0ED
  37. GETARY2   equ $E0EF
  38. GETARYPT  equ $F7D9
  39. PTRGET    equ $DFE3
  40. ARYPNT    equ $94
  41. REASON    equ $D3E3
  42. STREND    equ $6D
  43. LOWTR     equ $9B
  44. STACK     equ $100
  45. NUMDIM    equ $0F
  46. SUBFLG    equ $14
  47. CHKCLS    equ $DEB8
  48. FRMEVL    equ $DD7B
  49. HIMEM     equ $73
  50. ARYTAB    equ $6B
  51. BACKIN1   equ $E03F
  52. SUBERR    equ $E196
  53. MORNAM    equ $E007
  54. VARPNT    equ $83
  55. NCLEAR    equ $D66C
  56. AMPER     equ $3F5
  57. SAVE      equ 183
  58. STORE     equ 168
  59. CLEAR     equ 189
  60.  
  61. *---------Internal Zpage--------
  62.  
  63. savex     equ 3
  64. temp      equ 4
  65. Product   equ $EB
  66. Multiplicand equ $17
  67. Multiplier equ $06
  68.  
  69. *-----------Monitor-------------
  70.  
  71. A1L       equ $3C
  72. Move_Start equ A1L
  73. A2L       equ $3E
  74. Move_End  equ A2L
  75. A4L       equ $42
  76. Move_To   equ A4L
  77. MOVE      equ $FE2C
  78. PCL       equ $3A
  79. INSDS2    equ $F88C
  80. LENGTH    equ $2F
  81. PCADJ     equ $F953
  82. COUT      equ $FDED
  83. cr        equ $8D
  84.  
  85. *------ProDOS and BASIC.SYSTEM------
  86.  
  87. GOSYSTEM  equ $BE70
  88. Memory_Top equ $96
  89. ERROUT    equ $BE09
  90. BADCALL   equ $BE8B
  91. GETBUFR   equ $BEF5
  92. File_Type equ $FD        ;make it a VAR file
  93. SREAD     equ $BED5
  94. DATE      equ $BF90
  95. TIME      equ $BF92
  96. Disk_Block equ 2         ;in pages
  97. Half_Block equ Disk_Block/2
  98. BITMAP    equ $BF58
  99. OFILACTV  equ $BE45
  100. TBUFPTR   equ $BE4A
  101. MACHID    equ $BF98
  102. create    equ $C0
  103. getinfo   equ $C4
  104. write     equ $CB
  105. open      equ $C8
  106. setmark   equ $CE
  107. read      equ $CA
  108. close     equ $CC
  109.  
  110. *===============================
  111. *       Install and Init
  112. *===============================
  113.  
  114.           use virt.macs  ;macro file
  115.           dsk Virt.Mem.obj ;object file name
  116.           org $4000
  117.  
  118. Installed?
  119.           mov #Memory_Top;temp+1
  120.           mov #0         ;temp
  121. :1        ldy #5
  122. :2        lda (temp),Y   ;check sig bytes
  123.           cmp Virtual_Array,Y
  124.           bne :3
  125.           dey
  126.           bpl :2
  127.           jmp Copyright  ;installed already, exit
  128. :3        dec temp+1
  129.           lda temp+1
  130.           cmp HIMEM+1
  131.           bcs :1
  132.  
  133. Get_Space
  134.           lda #>End-Virtual_Array+$100
  135.           jsr GETBUFR
  136.           bcc :1
  137.           jmp ERROUT     ;crash on error
  138. :1        sta CHRGET+2   ;save page #
  139.           sta A1L
  140.           sec            ;compute how far
  141.           sbc #>Virtual_Array ;  to move code
  142.           sta temp       ;  and save for later.
  143.  
  144. Protect_Space
  145.           mov #>End-Virtual_Array+$100;A1L+1
  146. :1        lda A1L
  147.           pha
  148.           lsr
  149.           lsr
  150.           lsr
  151.           tax
  152.           pla
  153.           eor #$FF
  154.           and #7
  155.           sec
  156.           tay
  157.           lda #0
  158. :2        rol
  159.           dey
  160.           bpl :2
  161.           ora BITMAP,X
  162.           sta BITMAP,X
  163.           inc A1L        ;do for all pages
  164.           dec A1L+1
  165.           bne :1
  166.  
  167. Fix_Addresses
  168.           movd AMPER+1   ;Daisy_Chain+1
  169.           mov #<Virtual_Array;PCL
  170.           mov #>Virtual_Array;PCL+1
  171. :1        ldx #0
  172.           jsr INSDS2     ;disassemble one instruction
  173.           lda (PCL),Y    ;BRK?
  174.           beq Relocate_Code ;yes, move it
  175.           ldy LENGTH     ;3-byte instruction?
  176.           cpy #2
  177.           bne :2         ;no, next
  178.           lda (PCL),Y    ;yes, is it within
  179.           cmp #>Virtual_Array ;  the code?
  180.           bcc :2         ;no, do next
  181.           cmp #>End+$100
  182.           bcs :2         ;no, do next
  183.           clc            ;else, fix address
  184.           adc temp
  185.           sta (PCL),Y
  186. :2        jsr PCADJ      ;get next instruction
  187.           sta PCL        ;point to it
  188.           sty PCL+1
  189.           jmp :1         ;and go again
  190.  
  191. Relocate_Code
  192.           ldy #0         ;set up monitor move
  193.           sty A1L
  194.           mov #>Virtual_Array;A1L+1
  195.           mov #<End      ;A2L
  196.           mov #>End      ;A2L+1
  197.           sty A4L
  198.           mov CHRGET+2   ;A4L+1
  199.           sta AMPER+2
  200.           jsr MOVE       ;and move code.
  201.           mov #$4C       ;CHRGET ;set vectors
  202.           sta AMPER
  203.           mov #<Virtual_Array;CHRGET+1
  204.           mov #<Amper_Interp;AMPER+1
  205.  
  206. Copyright
  207.           print cr,cr
  208.           print "             Virtual Memory"
  209.           print cr
  210.           print "           for Applesoft BASIC"
  211.           print cr
  212.           print "               Version 2.0"
  213.           print cr,cr
  214.           print "            by John R. Vokey"
  215.           print cr
  216.           print "      Copyright 1990 MindCraft Publ."
  217.           print cr,cr
  218.           rts            ;back to basic
  219.  
  220. sendmsg   pull temp
  221.           bne :3
  222. :1        bit MACHID     ;flag // and //+
  223.           bmi :2         ;//e or greater
  224.           cmp #$E0       ;convert to upper-case
  225.           bcc :2
  226.           and #$DF
  227. :2        jsr COUT
  228. :3        ldy #0
  229.           incr temp
  230.           lda (temp),Y
  231.           bne :1
  232.           push temp
  233.           rts
  234.  
  235.           lst off
  236.           ds \           ;skip to next page boundary
  237.           lst on
  238.  
  239. *=================================
  240. *         Virtual_Array
  241. *=================================
  242.  
  243. Virtual_Array
  244.           pull temp      ;retrieve caller
  245.           cmp #>MORNAM   ;from MORNAM?
  246.           bne :1         ;no, exit
  247.           lda #<MORNAM+2
  248.           cmp temp
  249.           beq VirtualArray? ;yes, do it
  250. :1        push temp      ;restore return address
  251.           incr TXTPTR    ;complete CHRGET
  252.           jmp CHRGOT
  253.  
  254. Amper_Interp
  255.           cmp #STORE     ;flush a virtual array?
  256.           bne :1
  257.           jmp Store_Token
  258. :1        cmp #CLEAR     ;clear variables?
  259.           bne :2
  260.           jmp Clear_Token
  261. :2        cmp #SAVE      ;create a virtual array?
  262.           bne Daisy_Chain
  263.           jmp Save_Token
  264. Daisy_Chain
  265.           jmp SYNERR     ;daisy-chain '&' calls
  266.  
  267. VirtualArray?
  268.           jsr More_Name  ;complete MORNAM
  269.           ora VALTYP     ;simple var or string array?
  270.           beq :1         ;no, check for array
  271.           jsr CHRGOT     ;else, recover char
  272.           jmp BACKIN1    ;  and exit.
  273.                          ;
  274. :1        jsr ARRAY2     ;process the array
  275.           bcc :2         ;if found, continue
  276.           jmp NOTFOUND else, exit
  277.  
  278. :2        ldy #4         ;check numdim
  279.           lda (LOWTR),Y  ;not a virtual array?
  280.           ora DIMFLG     ;dimension it?
  281.           ora SUBFLG     ;from GETARYPT?
  282.           beq :3         ;if all no, continue
  283.           jmp ARYFOUND else, exit
  284.  
  285. :3        iny            ;it's a virtual array!
  286.           lda (LOWTR),Y  ;get true num dims
  287.           cmp NUMDIM     ;same as requested?
  288.           beq Check_Dims ;yes, continue
  289. Do_SUBERR jmp SUBERR     ;else, subscript error
  290.  
  291. Check_Dims
  292.           mov #0         ;Product ;clear mult locs
  293.           sta Product+1
  294.           sta Product+2
  295. :1        pla            ;low byte of index
  296.           tax
  297.           sta FAC+3
  298.           pla            ;get high byte
  299.           sta FAC+4
  300.           iny
  301.           cmp (LOWTR),Y  ;< = DIM?
  302.           bcc :2         ;yes, do it
  303.           bne Do_SUBERR  ;else, SUBSCRIPT error
  304.           iny
  305.           txa
  306.           cmp (LOWTR),Y  ;<DIM?
  307.           bcs Do_SUBERR  ;no, SUBSCRIPT error
  308.           dey            ;point to high byte
  309. :2        mov (LOWTR),Y  ;Multiplier+1
  310.           iny
  311.           mov (LOWTR),Y  ;Multiplier
  312.           lda Product    ;first pass?
  313.           ora Product+1
  314.           ora Product+2
  315.           beq :3         ;yes, branch
  316.           jsr Mult_16x24 ;else, multiply dims
  317. :3        clc
  318.           lda FAC+3      ;add in number of each
  319.           adc Product
  320.           sta Product
  321.           lda Product+1
  322.           adc FAC+4
  323.           sta Product+1
  324.           lda Product+2
  325.           adc #0
  326.           sta Product+2
  327.           dec NUMDIM     ;next dimension
  328.           bne :1
  329.           ldx #5         ;assume real array
  330.           lda VARNAM     ;is it?
  331.           bpl :4         ;yes, continue
  332.           ldx #2         ;else, integer array
  333. :4        stx Multiplier ;DIMS * size (X)
  334.           stx savex      ;save type for later
  335.           mov #0         ;Multiplier+1 ;set up last MULT
  336.           jsr Mult_16x24 ;and do it
  337.           ldy #5         ;recover NUMDIM
  338.           mov (LOWTR),Y  ;NUMDIM
  339.  
  340. DataInMemory?
  341.           jsr GETARY     ;point to internal vars
  342.           ldy #3         ;Product < CURBYTE?
  343. :1        lda Product-1,Y
  344.           cmp (ARYPNT),Y
  345.           bcc :4         ;yes, get new block
  346.           bne :2         ;else, check high end
  347.           dey
  348.           bne :1
  349. :2        sec            ;compute # bytes
  350.           lda #0         ;subtract size
  351.           sbc savex
  352.           sta Multiplicand
  353.           lda #Disk_Block
  354.           sbc #0
  355.           sta Multiplicand+1
  356.           clc
  357.           ldy #1         ;compute high end
  358.           lda (ARYPNT),Y
  359.           adc Multiplicand
  360.           sta Multiplicand
  361.           iny
  362.           lda (ARYPNT),Y
  363.           adc Multiplicand+1
  364.           sta Multiplicand+1
  365.           iny
  366.           lda (ARYPNT),Y
  367.           adc #0
  368.           sta Multiplicand+2
  369.           dey
  370. :3        lda Product,Y  ;Product < End?
  371.           cmp Multiplicand,Y
  372.           bcc ComputeOffset ;yes, continue
  373.           bne :4         ;else, get data
  374.           dey
  375.           bpl :3
  376. :4        jsr Array_Write ;WRITE back old block
  377.           jsr Array_Read2 ;READ in new block
  378.  
  379. ComputeOffset
  380.           sec
  381.           ldy #1
  382.           lda Product
  383.           sbc (ARYPNT),Y
  384.           sta VARPNT
  385.           lda Product+1
  386.           iny
  387.           sbc (ARYPNT),Y
  388.           sta VARPNT+1
  389.           jsr Pnt_to_Data ;point to data
  390.           clc
  391.           lda ARYPNT     ;compute offset to value
  392.           adc VARPNT
  393.           sta VARPNT
  394.           lda ARYPNT+1
  395.           adc VARPNT+1
  396.           sta VARPNT+1
  397.           tay
  398.           lda VARPNT
  399.           rts            ;return as BASIC expects
  400.  
  401. Store_Token
  402.           jsr CHRGET     ;move TXTPTR to name
  403. :1        jsr GETARYPT   ;find array (error if none)
  404.           ldy #4
  405.           lda (LOWTR),Y  ;is it virtual?
  406.           beq :2         ;yes, continue
  407.           ldx #128       ;else
  408.           jmp ERROR      ;make 'ARRAY ERROR'
  409. :2        iny            ;get NUMDIM
  410.           mov (LOWTR),Y  ;NUMDIM
  411.           jsr Array_Write ;write the data
  412.           jsr Array_Close ;close virtual file
  413.           jsr CHRGOT     ;check for more
  414.           bne :3
  415.           rts
  416. :3        jsr CHKCOM     ;must be comma
  417.           jmp :1
  418.  
  419. Clear_Token
  420.           jsr CHRGET     ;move TXTPTR to var name
  421.           bne :1         ;exit if normal CLEAR
  422.           jmp NCLEAR
  423. :1        jsr PTRGET     ;get var
  424.           cpy ARYTAB+1   ;simple or array var?
  425.           bne :2         ;flag in carry (set = array)
  426.           cmp ARYTAB
  427. :2        ldy #2
  428.           php
  429.           bcs :3         ;array var, go
  430.           lda #0         ;create dummy offset for
  431.           iny            ;simple vars
  432.           sta (LOWTR),Y
  433.           dey
  434.           lda #7
  435.           sta (LOWTR),Y
  436. :3        clc
  437.           lda (LOWTR),Y  ;get offset to next var
  438.           sta temp
  439.           lda LOWTR      ;set up move
  440.           sta Move_To
  441.           adc temp
  442.           sta Move_Start
  443.           lda LOWTR+1
  444.           sta Move_To+1
  445.           iny
  446.           adc (LOWTR),Y
  447.           sta Move_Start+1
  448.           lda (LOWTR),Y
  449.           sta temp+1
  450.           ldy #0
  451.           lda STREND
  452.           sta Move_End
  453.           lda STREND+1
  454.           sta Move_End+1
  455.           jsr MOVE       ;and move, erasing var
  456.           lda STREND     ;set STREND to new val
  457.           sbc temp
  458.           sta STREND
  459.           lda STREND+1
  460.           sbc temp+1
  461.           sta STREND+1
  462.           plp            ;recover simple or array
  463.           bcs :4         ;if simple, fix ARYTAB
  464.           lda ARYTAB
  465.           sbc #6
  466.           sta ARYTAB
  467.           bcs :4
  468.           dec ARYTAB+1
  469. :4        jsr CHRGOT     ;more?
  470.           bne :5
  471.           rts
  472. :5        jsr CHKCOM     ;must be comma
  473.           jmp :1
  474.  
  475. Save_Token
  476.           jsr CHRGET     ;move TXTPTR to name
  477.           jsr FRMEVL     ;evaluate it
  478.           jsr CHKSTR     ;must be string
  479.           ldy #0         ;save length and handle
  480.           mov (FAC+3),Y  ;templength
  481.           movd FAC+3     ;temphandle
  482.           jsr CHKCOM     ;comma?
  483.           sta DIMFLG     ;set dimflg
  484.           sta VARNAM     ;save 1st char of var
  485.           jsr ISLETC     ;letter?
  486.           bcs NAMOK      ;yes, continue
  487. BADNAM    jmp SYNERR     ;no, bad name
  488. NAMOK     ldx #0
  489.           stx VALTYP     ;clear flags
  490.           stx INTFLG
  491.           jsr More_Name  ;process second char
  492.           ora VALTYP     ;simple var or string?
  493.           bne BADNAM     ;yes, error
  494.           jsr ARRAY2     ;process array
  495.           bcs :1         ;not found, continue
  496.           jmp ARYFOUND   ;else, error
  497. :1        jsr New_GETARY
  498.           lda templength ;recover pathname length
  499.           jsr Pnt_to_Data2
  500.           adc #1
  501.           sta temp
  502.           tya
  503.           adc #Disk_Block
  504.           sta temp+1
  505.           tay
  506.           lda temp
  507.           jsr REASON     ;enough room for array?
  508.  
  509. SaveArrayInfo
  510.           ldy #0
  511.           sty Product+1 (clear mult Product)
  512.           sty Product+2
  513.           ldx #5         ;assume real array
  514.           mov VARNAM     ;(LOWTR),Y ;get first char
  515.           bpl :1         ;if real, go
  516.           ldx #2         ;else, integer array
  517. :1        iny
  518.           mov VARNAM+1   ;(LOWTR),Y
  519.           iny            ;point to offset locs
  520.           sec            ;calculate offset
  521.           lda temp       ;recover last byte
  522.           sbc LOWTR      ;subtract first byte
  523.           sta (LOWTR),Y  ;offset to next var
  524.           iny
  525.           lda temp+1
  526.           sbc LOWTR+1
  527.           sta (LOWTR),Y
  528.           iny
  529.           mov #0         ;(LOWTR),Y ;flag virtual array
  530.           iny            ;save true numdim
  531.           mov NUMDIM     ;(LOWTR),Y ;one byte later
  532.           stx Product    ;for mult (DIMS * size)
  533.  
  534. CalculateSize
  535.           pla            ;recover lbyte of dim
  536.           clc
  537.           adc #1         ;plus 1
  538.           tax            ;save temporarily
  539.           pla            ;hbyte of dim
  540.           adc #0
  541.           iny
  542.           sta (LOWTR),Y  ;save hbyte of dim
  543.           sta Multiplier+1 ;and in Multiplier (for mult)
  544.           iny
  545.           txa
  546.           sta (LOWTR),Y  ;save lbyte of dim
  547.           sta Multiplier ;and in Multiplier
  548.           jsr Mult_16x24 ;DIM * OLD Product
  549.           dec NUMDIM     ;next dimension
  550.           bne CalculateSize
  551.  
  552. SaveArrayPrms
  553.           lda #0         ;do CURBYTE
  554.           ldx #3
  555. :1        iny
  556.           sta (LOWTR),Y
  557.           dex
  558.           bpl :1
  559.           iny
  560.           mov #Disk_Block;(LOWTR),Y ;set NUMBYTES
  561.           ldy #5         ;recover NUMDIM
  562.           mov (LOWTR),Y  ;NUMDIM
  563.           jsr New_GETARY ;point to name buf
  564.           lda temphandle ;recover handle
  565.           ldy temphandle+1
  566.           jsr FRETMP     ;and dispose of it
  567.           ldy #0
  568.           sta (ARYPNT),Y ;save pathname length
  569.           tay
  570. :2        dey
  571.           lda (INDEX),Y  ;save pathname
  572.           iny
  573.           sta (ARYPNT),Y
  574.           dey
  575.           bne :2
  576.           jsr Pnt_to_Data
  577.           ldx #Disk_Block
  578.           lda #0
  579.           tay
  580. :3        sta (ARYPNT),Y ;clear array
  581.           iny
  582.           bne :3
  583.           inc ARYPNT+1
  584.           dex
  585.           bne :3
  586.  
  587. Create_File
  588.           jsr New_GETARY ;point to pathname
  589.           movd ARYPNT    ;createparms+1
  590.           movd ARYPNT    ;getinfoparms+1
  591.           movd ARYPNT    ;openparms+1
  592.           movd DATE      ;createparms+8
  593.           movd TIME      ;createparms+10
  594.           go_dos create  ;createparms
  595.           bcc :3
  596.           cmp #19        ;Duplicate file error?
  597.           bne :2         ;no, crash
  598.           go_dos getinfo ;getinfoparms
  599.           lda getinfoparms+4 ;get file type
  600.           cmp #File_Type
  601.           bne :1         ;if not virtual, crash
  602.           lda getinfoparms+6
  603.           cmp #"V"       ;'V'irtual
  604.           bne :1
  605.           lda getinfoparms+5
  606.           cmp #"A"       ;'A'rray?
  607.           bne :1
  608.           jsr Set_STREND ;else, set STREND
  609.           jmp Array_Read ;  and read in block 1
  610. :1        lda #19        ;else, crash
  611. :2        jmp ERROUT
  612.  
  613. :3        clc
  614.           ror Product+2
  615.           ror Product+1
  616.           jsr Array_Open ;open file
  617.           jsr Pnt_to_Data ;point to data
  618.           sta writeparms+2
  619.           sty writeparms+3
  620.           mov #0         ;writeparms+4
  621.           mov #Disk_Block;writeparms+5
  622. :4        go_dos write   ;writeparms ;write it
  623.           bcc :5
  624.           jmp Read_Error
  625. :5        lda Product+1
  626.           ora Product+2
  627.           beq :7         ;do for all blocks
  628.           lda Product+1
  629.           bne :6
  630.           dec Product+2
  631. :6        dec Product+1
  632.           jmp :4
  633. :7        jsr Array_Close
  634.  
  635. Set_STREND
  636.           movd temp      ;STREND
  637.           rts            ;and back to BASIC
  638.  
  639. More_Name                ;replaces Applesoft MORNAM
  640.           jsr CHRGET
  641.           bcc OV
  642.           jsr ISLETC
  643.           bcc STR
  644. OV        tax
  645. BY        jsr CHRGET
  646.           bcc BY
  647.           jsr ISLETC
  648.           bcs BY
  649. STR       cmp #'$'
  650.           bne INTV
  651.           mov #$FF       ;VALTYP
  652.           bne NIN
  653. INTV      cmp #'%'
  654.           bne SECND
  655.           lda SUBFLG
  656.           bpl MINTV
  657.           jmp SYNERR
  658. MINTV     mov #$80       ;INTFLG
  659.           ora VARNAM
  660.           sta VARNAM
  661. NIN       txa
  662.           ora #$80
  663.           tax
  664.           jsr CHRGET
  665. SECND     stx VARNAM+1
  666.           sec
  667.           ora SUBFLG
  668.           sbc #'('
  669.           rts
  670.  
  671. ARRAY2                   ;replaces Applesoft ARRAY code
  672.                          ;to allow arrays >64k
  673.           lda SUBFLG
  674.           bne FNDARY2
  675.           lda DIMFLG
  676.           ora INTFLG
  677.           pha
  678.           lda VALTYP
  679.           pha
  680.           ldy #0
  681. NXTDIM    tya
  682.           pha
  683.           push VARNAM
  684.           jsr MAKINT
  685.           pull VARNAM
  686.           pla
  687.           tay
  688.           tsx
  689.           lda STACK+2,X
  690.           pha
  691.           lda STACK+1,X
  692.           pha
  693.           lda STACK+4,X
  694.           sta STACK+2,X
  695.           lda STACK+3,X
  696.           sta STACK+1,X
  697.           mov FAC+3      ;STACK+4,X
  698.           mov FAC+4      ;STACK+3,X
  699.           iny            ;counts dim number
  700.           jsr CHRGOT
  701.           cmp #','
  702.           beq NXTDIM
  703.           sty NUMDIM
  704.           jsr CHKCLS
  705.           pull VALTYP
  706.           and #$7F
  707.           sta DIMFLG
  708. FNDARY2   ldx ARYTAB
  709.           lda ARYTAB+1
  710. ARYLOOP   stx LOWTR
  711.           sta LOWTR+1
  712.           cmp STREND+1
  713.           bne ARYNAM
  714.           cpx STREND
  715.           beq NOTFND2
  716. ARYNAM    ldy #0
  717.           lda (LOWTR),Y
  718.           iny
  719.           cmp VARNAM
  720.           bne NXARY
  721.           lda VARNAM+1
  722.           cmp (LOWTR),Y
  723.           beq ARYFND2
  724. NXARY     iny
  725.           lda (LOWTR),Y
  726.           clc
  727.           adc LOWTR
  728.           tax
  729.           iny
  730.           lda (LOWTR),Y
  731.           adc LOWTR+1
  732.           bcc ARYLOOP
  733. ARYFND2   clc            ;Flag found array
  734. NOTFND2   rts
  735.  
  736. Mult_16x24
  737.           ldx #2         ;Product -> Multiplicand
  738. :1        mov Product,X  ;Multiplicand,X
  739.           dex
  740.           bpl :1
  741. MUL       ldx #4         ;alternate entry
  742.           lda #0
  743. :2        sta Product,X
  744.           dex
  745.           bpl :2
  746.           ldx #16        ;16-bit Multiplier
  747. :3        lsr Multiplier+1
  748.           ror Multiplier
  749.           bcc :4
  750.           clc
  751.           lda Product+2
  752.           adc Multiplicand
  753.           sta Product+2
  754.           lda Product+3
  755.           adc Multiplicand+1
  756.           sta Product+3
  757.           lda Product+4
  758.           adc Multiplicand+2
  759.           sta Product+4
  760. :4        lsr Product+4
  761.           ror Product+3
  762.           ror Product+2
  763.           ror Product+1
  764.           ror Product
  765.           dex
  766.           bne :3
  767.           lda Product+3
  768.           ora Product+4  ; > 16 meg (ProDOS limit)?
  769.           beq NOTFND2    ; no, exit
  770.           jmp MEMERR     ; yes, memory error
  771.  
  772. Array_Open
  773.           lda OFILACTV   ;active output file?
  774.           beq :1         ;no, open virtual file
  775.           lda TBUFPTR    ;Yes, bytes buffered?
  776.           beq :1         ;no, open virtual file
  777.           sta SREAD+4    ;Yes, store how many
  778.           mov #0         ;SREAD+5
  779.           go_sys write   ;and WRITE them.
  780.           bcs Open_Error
  781.           lda #0         ;clear buffered byte count
  782.           sta TBUFPTR
  783. :1        jsr New_GETARY ;get pathname pointer
  784.           sta openparms+1
  785.           sty openparms+2
  786.           mov #0         ;openparms+3 ;set OPEN parameters
  787.           mov HIMEM+1    ;openparms+4
  788.           go_dos open    ;openparms ;open file
  789.           bcs Open_Error
  790.           lda openparms+5 ;recover REFNUM
  791.           sta readparms+1 ;and save within other
  792.           sta closeparms+1 ;globals
  793.           sta setmrkparms+1
  794.           rts
  795. Open_Error jmp ERROUT
  796.  
  797. Array_Read
  798.           jsr Array_Open ;OPEN file
  799. Array_Read2 mov Product  ;setmrkparms+2
  800.           lda Product+2  ;set MARK
  801.           ora Product+1
  802.           bne :1
  803.           sta setmrkparms+2 ;to zero
  804.           sta setmrkparms+3 ;if first block
  805.           beq :2
  806. :1        lda Product+1  ;else, load a block
  807.           sec            ;with requested value
  808.           sbc #Half_Block ;at midpoint
  809.           sta setmrkparms+3
  810.           lda Product+2
  811.           sbc #0
  812. :2        sta setmrkparms+4
  813.           go_dos setmark ;setmrkparms
  814.           bcs Read_Error
  815.           mov #0         ;readparms+4
  816.           mov #Disk_Block;readparms+5
  817.           jsr Pnt_to_Data ;point to data
  818.           sta readparms+2
  819.           sty readparms+3
  820.           go_dos read    ;readparms ;and read it
  821.           bcc :3
  822.           cmp #5         ;end of data?
  823.           bne Read_Error
  824. :3        jsr GETARY     ;mark CURBYTE & NUMBYTES
  825.           ldy #1
  826.           mov setmrkparms+2;(ARYPNT),Y
  827.           iny
  828.           mov setmrkparms+3;(ARYPNT),Y
  829.           iny
  830.           mov setmrkparms+4;(ARYPNT),Y
  831.           iny
  832.           mov readparms+6;(ARYPNT),Y
  833.           iny
  834.           mov readparms+7;(ARYPNT),Y
  835.           lda #0
  836. Read_Error pha           ;save error code
  837.           jsr Array_Close ;CLOSE file
  838.           pla            ;recover error code
  839.           bne Close_Error ;if error, go
  840.           rts
  841.  
  842. Array_Write
  843.           jsr Array_Open
  844. Array_Write2 jsr GETARY
  845.           ldy #1
  846.           mov (ARYPNT),Y ;setmrkparms+2
  847.           iny
  848.           mov (ARYPNT),Y ;setmrkparms+3
  849.           iny
  850.           mov (ARYPNT),Y ;setmrkparms+4
  851.           iny
  852.           mov (ARYPNT),Y ;writeparms+4
  853.           iny
  854.           mov (ARYPNT),Y ;writeparms+5
  855.           go_dos setmark ;setmrkparms
  856.           bcs Read_Error
  857.           jsr Pnt_to_Data ;point to DATA
  858.           sta writeparms+2
  859.           sty writeparms+3
  860.           go_dos write   ;writeparms ;and write it
  861.           bcs Read_Error
  862. an_rts    rts
  863.  
  864. Array_Close
  865.           go_dos close   ;closeparms ;CLOSE virtual file
  866.           bcc an_rts
  867. Close_Error jmp ERROUT
  868.  
  869. Pnt_to_Data
  870.           jsr New_GETARY
  871.           ldy #0
  872.           lda (ARYPNT),Y ;get name length
  873.           clc
  874.           adc #1
  875. Pnt_to_Data2
  876.           clc
  877.           adc ARYPNT     ;add to current loc
  878.           sta ARYPNT
  879.           lda ARYPNT+1
  880.           adc #0
  881.           sta ARYPNT+1
  882.           tay            ;save hbyte
  883.           lda ARYPNT     ;and lbyte
  884.           rts
  885.  
  886. New_GETARY lda NUMDIM
  887.           clc
  888.           adc #3
  889.           jmp GETARY2
  890.  
  891. do_dos    sta *+6
  892.           jsr $BF00
  893.           lda createparms ;dummy code for relocate
  894.           bcc an_rts
  895.           jmp BADCALL    ;translate error code
  896.  
  897. templength ds 1
  898. temphandle ds 2
  899.  
  900. createparms db 7
  901.           dw 0
  902.           db $C3,$FD
  903.           asc "AV"
  904.           db 1
  905.           dw 0,0
  906. getinfoparms
  907.           db $A
  908.           ds 17
  909. setmrkparms
  910.           db 2,0,0,0,0
  911. openparms
  912.           db 3
  913.           ds 5
  914. readparms
  915. writeparms
  916.           db 4,0
  917.           dw 0,0,0
  918. closeparms
  919.           db 1,0
  920.           chk            ;checksum byte (= $E5)
  921. End
  922.           lst off        ;kill symbol table
  923.